home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / cmpnew / cmptag.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  8KB  |  208 lines
  1. ;;; CMPTAG  Tagbody and Go.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (si:putprop 'tagbody 'c1tagbody 'c1special)
  10. (si:putprop 'tagbody 'c2tagbody 'c2)
  11.  
  12. (si:putprop 'go 'c1go 'c1special)
  13. (si:putprop 'go 'c2go 'c2)
  14.  
  15. (defstruct tag
  16.            name            ;;; Tag name.
  17.            ref            ;;; Referenced or not.  T or NIL.
  18.            ref-clb        ;;; Cross local function reference.
  19.                        ;;; During Pass1, T or NIL.
  20.                        ;;; During Pass2, the vs-address for the
  21.                        ;;; tagbody id, or NIL.
  22.            ref-ccb        ;;; Cross closure reference.
  23.                        ;;; During Pass1, T or NIL.
  24.                        ;;; During Pass2, the vs-address for the
  25.                        ;;; block id, or NIL.
  26.            label        ;;; Where to jump.  A label.
  27.            unwind-exit        ;;; Where to unwind-no-exit.
  28.            var            ;;; The tag-name holder.  A VV index.
  29.            )
  30.  
  31. (defvar *tags* nil)
  32.  
  33. ;;; During Pass 1, *tags* holds a list of tag objects and the symbols 'CB'
  34. ;;; (Closure Boundary) and 'LB' (Level Boundary).  'CB' will be pushed on
  35. ;;; *tags* when the compiler begins to process a closure.  'LB' will be pushed
  36. ;;; on *tags* when *level* is incremented.
  37.  
  38. (defun c1tagbody (body &aux (*tags* *tags*) (info (make-info)))
  39.   ;;; Establish tags.
  40.   (setq body
  41.         (mapcar
  42.          #'(lambda (x)
  43.              (cond ((or (symbolp x) (integerp x))
  44.                     (let ((tag (make-tag :name x :ref nil
  45.                                          :ref-ccb nil :ref-clb nil)))
  46.                       (push tag *tags*)
  47.                       tag))
  48.                    (t x)))
  49.          body))
  50.  
  51.   ;;; Process non-tag forms.
  52.   (setq body (mapcar #'(lambda (x) (if (typep x 'tag) x (c1expr* x info)))
  53.                      body))
  54.  
  55.   ;;; Delete redundant tags.
  56.   (do ((l body (cdr l))
  57.        (body1 nil) (ref nil) (ref-clb nil) (ref-ccb nil))
  58.       ((endp l)
  59.        (if (or ref-ccb ref-clb ref)
  60.            (list 'tagbody info ref-clb ref-ccb (reverse body1))
  61.            (list 'progn info (reverse (cons (c1nil) body1)))))
  62.     (declare (object l ref ref-clb ref-ccb))
  63.     (if (typep (car l) 'tag)
  64.         (cond ((tag-ref-ccb (car l))
  65.                (push (car l) body1)
  66.                (setf (tag-var (car l)) (add-object (tag-name (car l))))
  67.                (setq ref-ccb t))
  68.               ((tag-ref-clb (car l))
  69.                (push (car l) body1)
  70.                (setf (tag-var (car l)) (add-object (tag-name (car l))))
  71.                (setq ref-clb t))
  72.               ((tag-ref (car l)) (push (car l) body1) (setq ref t)))
  73.         (push (car l) body1))))
  74.  
  75. (defun c2tagbody (ref-clb ref-ccb body)
  76.   (cond (ref-ccb (c2tagbody-ccb body))
  77.         (ref-clb (c2tagbody-clb body))
  78.         (t (c2tagbody-local body))))
  79.  
  80. (defun c2tagbody-local (body &aux (label (next-label)))
  81.   ;;; Allocate labels.
  82.   (dolist** (x body)
  83.     (when (typep x 'tag)
  84.           (setf (tag-label x) (next-label*))
  85.           (setf (tag-unwind-exit x) label)))
  86.   (let ((*unwind-exit* (cons label *unwind-exit*)))
  87.     (c2tagbody-body body))
  88.  
  89.   )
  90.  
  91. (defun c2tagbody-body (body)
  92.   (do ((l body (cdr l)) (written nil))
  93.       ((endp (cdr l))
  94.        (cond (written (unwind-exit nil))
  95.              ((typep (car l) 'tag)
  96.               (wt-label (tag-label (car l)))
  97.               (unwind-exit nil))
  98.              (t (let* ((*exit* (next-label))
  99.                        (*unwind-exit* (cons *exit* *unwind-exit*))
  100.                        (*value-to-go* 'trash))
  101.                   (c2expr (car l))
  102.                   (wt-label *exit*))
  103.                 (unless (eq (caar l) 'go) (unwind-exit nil)))))
  104.       (declare (object l written))
  105.     (cond (written (setq written nil))
  106.           ((typep (car l) 'tag) (wt-label (tag-label (car l))))
  107.           (t (let* ((*exit* (if (typep (cadr l) 'tag)
  108.                                 (progn (setq written t) (tag-label (cadr l)))
  109.                                 (next-label)))
  110.                     (*unwind-exit* (cons *exit* *unwind-exit*))
  111.                     (*value-to-go* 'trash))
  112.                (c2expr (car l))
  113.                (wt-label *exit*))))))
  114.  
  115. (defun c2tagbody-clb (body &aux (label (next-label)) (*vs* *vs*))
  116.   (let ((*unwind-exit* (cons 'frame *unwind-exit*))
  117.         (ref-clb (vs-push)))
  118.     (wt-nl) (wt-vs ref-clb) (wt "=alloc_frame_id();")
  119.     (wt-nl "frs_push(FRS_CATCH,") (wt-vs ref-clb) (wt ");")
  120.     (wt-nl "if(nlj_active){")
  121.     (wt-nl "nlj_active=FALSE;")
  122.     ;;; Allocate labels.
  123.     (dolist** (tag body)
  124.       (when (typep tag 'tag)
  125.         (setf (tag-label tag) (next-label))
  126.         (setf (tag-unwind-exit tag) label)
  127.         (when (tag-ref-clb tag)
  128.           (setf (tag-ref-clb tag) ref-clb)
  129.           (wt-nl "if(eql(nlj_tag,VV[" (tag-var tag) "]))")
  130.           (wt-go (tag-label tag)))))
  131.     (wt-nl "FEerror(\"The GO tag ~s is not established.\",1,nlj_tag);")
  132.     (wt-nl "}")
  133.     (let ((*unwind-exit* (cons label *unwind-exit*)))
  134.       (c2tagbody-body body))))
  135.  
  136. (defun c2tagbody-ccb (body &aux (label (next-label))
  137.                            (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*))
  138.   (let ((*unwind-exit* (cons 'frame *unwind-exit*))
  139.         (ref-clb (vs-push)) ref-ccb)
  140.     (wt-nl) (wt-vs ref-clb) (wt "=alloc_frame_id();")
  141.     (wt-nl) (wt-vs ref-clb) (wt "=MMcons(") (wt-vs ref-clb) (wt ",")
  142.     (wt-clink) (wt ");")
  143.     (clink ref-clb)
  144.     (setq ref-ccb (ccb-vs-push))
  145.     (wt-nl "frs_push(FRS_CATCH,") (wt-vs* ref-clb) (wt ");")
  146.     (wt-nl "if(nlj_active){")
  147.     (wt-nl "nlj_active=FALSE;")
  148.     ;;; Allocate labels.
  149.     (dolist** (tag body)
  150.       (when (typep tag 'tag)
  151.         (setf (tag-label tag) (next-label*))
  152.         (setf (tag-unwind-exit tag) label)
  153.         (when (or (tag-ref-clb tag) (tag-ref-ccb tag))
  154.           (setf (tag-ref-clb tag) ref-clb)
  155.           (when (tag-ref-ccb tag) (setf (tag-ref-ccb tag) ref-ccb))
  156.           (wt-nl "if(eql(nlj_tag,VV[" (tag-var tag) "]))")
  157.           (wt-go (tag-label tag)))))
  158.     (wt-nl "FEerror(\"The GO tag ~s is not established.\",1,nlj_tag);")
  159.     (wt-nl "}")
  160.     (let ((*unwind-exit* (cons label *unwind-exit*)))
  161.       (c2tagbody-body body))))
  162.  
  163. (defun c1go (args)
  164.   (cond ((endp args) (too-few-args 'go 1 0))
  165.         ((not (endp (cdr args))) (too-many-args 'go 1 (length args)))
  166.         ((not (or (symbolp (car args)) (integerp (car args))))
  167.          "The tag name ~s is not a symbol nor an integer." (car args)))
  168.   (do ((tags *tags* (cdr tags))
  169.        (name (car args))
  170.        (ccb nil) (clb nil))
  171.       ((endp tags) (cmperr "The tag ~s is undefined." name))
  172.       (declare (object name ccb clb))
  173.     (case (car tags)
  174.       (cb (setq ccb t))
  175.       (lb (setq clb t))
  176.       (t (when (eq (tag-name (car tags)) name)
  177.            (let ((tag (car tags)))
  178.              (cond (ccb (setf (tag-ref-ccb tag) t))
  179.                    (clb (setf (tag-ref-clb tag) t))
  180.                    (t (setf (tag-ref tag) t)))
  181.              (return (list 'go *info* clb ccb tag))))))))
  182.  
  183. (defun c2go (clb ccb tag)
  184.   (cond (ccb (c2go-ccb tag))
  185.         (clb (c2go-clb tag))
  186.         (t (c2go-local tag))))
  187.  
  188. (defun c2go-local (tag)
  189.   (unwind-no-exit (tag-unwind-exit tag))
  190.   (wt-nl) (wt-go (tag-label tag)))
  191.  
  192. (defun c2go-clb (tag)
  193.   (wt-nl "vs_base=vs_top;")
  194.   (wt-nl "unwind(frs_sch(")
  195.   (if (tag-ref-ccb tag)
  196.       (wt-vs* (tag-ref-clb tag))
  197.       (wt-vs (tag-ref-clb tag)))
  198.   (wt "),VV[" (tag-var tag) "]);"))
  199.  
  200. (defun c2go-ccb (tag)
  201.   (wt-nl "{frame_ptr fr;")
  202.   (wt-nl "fr=frs_sch(") (wt-ccb-vs (tag-ref-ccb tag)) (wt ");")
  203.   (wt-nl "if(fr==NULL)FEerror(\"The GO tag ~s is missing.\",1,VV["
  204.          (tag-var tag) "]);")
  205.   (wt-nl "vs_base=vs_top;")
  206.   (wt-nl "unwind(fr,VV[" (tag-var tag) "]);}"))
  207.  
  208.